Programmer Power Tools/Programmer Power Tools.iso/microcrn/issue_49.arc/GENSORT.ARC/GENSRT.M2

Text File | 1989-07-11 | 9.7 KB | 323 lines

(* Micro Cornucopia Magazine Issue #49
   Units and Modules Figure 1 - Generic sort routines *)

unit GenSort;

(*
  Author: Michael S. Hunt    Date: June 1, 1989
  This source code is release into the public domain.
*)

interface

const MAX_KEYS = 16;
      MAX_SRTS = 8;
      MAX_MSG = 10;
      MAX_DATA_LEN = 32768;
      MSG_SIZE = 40;
      srtMsg : array[1..MAX_MSG] of string[MSG_SIZE] =
                   ('successful operation',
                    'zero records left to retrieve ',
                    'routines called in incorrect order',
                    'maximum sorts exceeded',
                    'too many keys',
                    'invalid sort id',
                    'not valid sort',
                    'sort in release state',
                    'sort in retrieve state',
                    'sort done');
      GenSrtErr_NM   =  0;   (* successful operation *)
      GenSrtErr_ZR   =  1;   (* zero records left to retrieve *)
      GenSrtErr_ICO  =  2;   (* routines called in incorrect order *)
      GenSrtErr_MSE  =  3;   (* maximum sorts exceeded *)
      GenSrtErr_TMK  =  4;   (* too many keys *)
      GenSrtErr_ISI  =  5;   (* invalid sort id *)
      GenSrtSt_NV    =  6;   (* not valid sort *)
      GenSrtSt_REL   =  7;   (* sort in release state *)
      GenSrtSt_RET   =  8;   (* sort in retrieve state *)
      GenSrtSt_DONE  =  9;   (* sort done *)
      GenSrtDType_BL =  1;   (* type boolean *)
      GenSrtDType_B  =  2;   (* type byte *)
      GenSrtDType_W  =  3;   (* type word *)
      GenSrtDType_C  =  4;   (* type char 1 byte *)
      GenSrtDType_ST =  5;   (* type string 1..255 bytes *)
      GenSrtOrder_A  =  0;   (* ascending sort order *)
      GenSrtOrder_D  =  1;   (* descending sort order *)

type  KeyRec = record
                   dataType, order, offset, length : word
               end;
      Keyarr = array[1..MAX_KEYS*4+1] of word;
      Bytes  = array[1..MAX_DATA_LEN] of byte;
      Chars  = array[1..MAX_DATA_LEN] of char;
      PtrRec = record
                 ofs, seg : word
               end;
      SrtKeyRec = record
                       nbrKeys : word;
                       key : array[1..MAX_KEYS] of KeyRec
                   end;
      SrtStatRec = record
                        nbrKeys, dataLen, keyLen, srtState : word;
                        nbrRec  : longint
                    end;
      SrtStr = string[80];

var   srtKeyArr  : array[1..MAX_SRTS] of SrtKeyRec;
      srtStatArr : array[1..MAX_SRTS] of SrtStatRec;

procedure GenSrtBegin (var key; dataLen : word; var srtId : word;
                      var srtStatus : word);

function GenSrtBeginF (var key; dataLen : word; var srtId : word) : word;

procedure GenSrtRelease (var rec; srtId : word; var srtStatus : word);

function GenSrtReleaseF (var rec; srtId : word) : word;

procedure GenSrtDoSrt (srtId : word; var srtStatus :word);

function GenSrtDoSrtF (srtId : word) : word;

procedure GenSrtRetrieve (var rec; srtId : word; var srtStatus : word);

function GenSrtRetrieveF (var rec; srtId : word) : word;

procedure GenSrtEnd (srtId : word; var srtStatus : word);

function GenSrtEndF (srtId : word) : word;

procedure GenSrtStat (var srtStatus : SrtStatRec; srtId :word);

procedure GenSrtMsg (srtStatus : word; var srtString : SrtStr);

implementation

uses GenBinTree;

var srtRootArr : array[1..MAX_SRTS] of treePtr;
    j : word;

function NextSrtId : word;
var  j : word;
     done : boolean;
begin
  j := 1;
  NextSrtId := 0;
  done := false;
  repeat
    if srtStatArr[j].srtState = GenSrtSt_NV then
    begin
      NextSrtId := j;
      done := true;
      srtStatArr[j].srtState := GenSrtSt_REL
    end;
    j := j+1
  until (j > MAX_SRTS) OR (done)
end;

function ValidSrtId(srtId : word) : boolean;
begin
  if (srtId <= MAX_SRTS) AND (srtId > 0) then
    if srtStatArr[srtId].srtState <> GenSrtSt_NV then
      ValidSrtId := true
    else
      ValidSrtId := false
end;

procedure ClearSrtId(srtId : word);
begin
  if (srtId <= MAX_SRTS) AND (srtId > 0) then
    srtStatArr[srtId].srtState := GenSrtSt_NV
end;

procedure Descend(var rec; recLen : word);
var j : word;
begin
  for j := 1 to recLen do
  begin
    Bytes(rec)[j] := $FF xor Bytes(rec)[j]
  end
end;

procedure GenSrtBegin (var key; dataLen : word; var srtId : word;
                      var srtStatus : word);
begin
    srtStatus := GenSrtBeginF(key, dataLen, srtID)
end;

function GenSrtBeginF (var key; dataLen : word; var srtId : word) : word;
var j, k : word;
begin
     srtId := NextSrtId;
     if srtId > 0 THEN
     begin
        srtKeyArr[srtId].nbrkeys := KeyArr(key)[1];
        if srtKeyArr[srtId].nbrkeys <= MAX_KEYS then
        begin
             for j := 1 to srtKeyArr[srtId].nbrKeys do
             begin
                 srtKeyArr[srtId].key[j].dataType := KeyArr(key)[j*4-2];
                 srtKeyArr[srtId].key[j].order := KeyArr(key)[j*4-1];
                 srtKeyArr[srtId].key[j].offset := KeyArr(key)[j*4];
                 srtKeyArr[srtId].key[j].length := KeyArr(key)[j*4+1]
             end;
             srtStatArr[srtId].nbrKeys := srtKeyArr[srtId].nbrKeys;
             srtStatArr[srtId].dataLen := dataLen;
             srtStatArr[srtId].keyLen := 0;
             for j := 1 to srtKeyArr[srtId].nbrKeys do
               srtStatArr[srtId].keyLen := srtStatArr[srtId].keyLen
                                        +  srtKeyArr[srtId].key[j].length;
             srtStatArr[srtId].nbrRec := 0;
             srtStatArr[srtId].srtState := GenSrtSt_REL;
             GenSrtBeginF := GenSrtErr_NM
        end
        else
        begin
            ClearSrtId(srtId);
            GenSrtBeginF := GenSrtErr_TMK
        end
     end
     else
         GenSrtBeginF := GenSrtErr_MSE
end;

procedure GenSrtRelease (var rec; srtId : word; var srtStatus : word);
begin
    srtStatus := GenSrtReleaseF(rec, srtId)
end;

function GenSrtReleaseF (var rec; srtId : word) : word;
var data, key, tkey : dataPtr;
    j, k : word;
begin
  if ValidSrtId(srtId) then
  begin
    k := 1;
    GetMem(key, srtStatArr[srtId].keyLen);
    GetMem(data, srtStatArr[srtId].dataLen);
    tkey := key;
    for j := 1 to srtKeyArr[srtId].nbrKeys do
    begin
      if (srtKeyArr[srtId].key[j].dataType = GenSrtDType_BL) then
      begin
        tkey^ := Chars(rec)[srtKeyArr[srtId].key[j].offset];
        Inc(PtrRec(tkey).ofs,1)
      end
      else if (srtKeyArr[srtId].key[j].dataType = GenSrtDType_B) then
      begin
        tkey^ := Chars(rec)[srtKeyArr[srtId].key[j].offset];
        Inc(PtrRec(tkey).ofs,1)
      end
      else if (srtKeyArr[srtId].key[j].dataType = GenSrtDType_W) then
      begin
        tkey^ := Chars(rec)[srtKeyArr[srtId].key[j].offset+1];
        Inc(PtrRec(tkey).ofs,1);
        tkey^ := Chars(rec)[srtKeyArr[srtId].key[j].offset];
        Inc(PtrRec(tkey).ofs,1)
      end
      else if (srtKeyArr[srtId].key[j].dataType = GenSrtDType_C) then
      begin
        tkey^ := Chars(rec)[srtKeyArr[srtId].key[j].offset];
        Inc(PtrRec(tkey).ofs,1)
      end
      else if (srtKeyArr[srtId].key[j].dataType = GenSrtDType_ST) then
      begin
        for k := 1 to srtKeyArr[srtId].key[j].length do
        begin
          tkey^ := Chars(rec)[srtKeyArr[srtId].key[j].offset+k];
          Inc(PtrRec(tkey).ofs,1)
        end
      end;
      if (srtKeyArr[srtId].key[j].order <> GenSrtOrder_A) then
      begin
        Descend(key^, srtKeyArr[srtId].key[j].length)
      end
    end;
    Move(rec, data^, srtStatArr[srtId].dataLen);
    GenBinInsert (srtRootArr[srtId], key, srtStatArr[srtId].keyLen,
               data, srtStatArr[srtId].dataLen);
    srtStatArr[srtId].nbrRec := srtStatArr[srtId].nbrRec + 1;
  end
  else
    GenSrtReleaseF := GenSrtErr_ISI
end;

procedure GenSrtDoSrt (srtId : word; var srtStatus :word);
begin
    srtStatus := GenSrtDoSrtF(srtId)
end;

function GenSrtDoSrtF (srtId : word) : word;
begin
  if ValidSrtId(srtId) then
  begin
    srtStatArr[srtId].srtState := GenSrtSt_RET;
    GenSrtDoSrtF := GenSrtErr_NM;
  end
  else
    GenSrtDoSrtF := GenSrtErr_ISI
end;

procedure GenSrtRetrieve (var rec; srtId : word; var srtStatus : word);
begin
    srtStatus := GenSrtRetrieveF(rec, srtId)
end;

function GenSrtRetrieveF (var rec; srtId : word) : word;
var d, k : dataPtr;
    dlen, klen : word;
begin
  if ValidSrtId(srtId) then
    if srtStatArr[srtId].srtState = GenSrtSt_RET then
      if srtStatArr[srtId].nbrRec > 0 then
      begin
        GenBinRetDelSmRec(srtRootArr[srtId], k, klen, d, dlen);
        Move(d^, rec, dlen);
        srtStatArr[srtId].nbrRec := srtStatArr[srtId].nbrRec - 1;
        GenSrtRetrieveF := GenSrtErr_NM;
      end
      else
        GenSrtretrieveF := GenSrtErr_ZR
    else
      GenSrtRetrieveF := GenSrtErr_ICO
  else
    GenSrtRetrieveF := GenSrtErr_ISI
end;

procedure GenSrtEnd (srtId : word; var srtStatus : word);
begin
    srtStatus := GenSrtEndF(srtId)
end;

function GenSrtEndF (srtId : word) : word;
var d, k : dataPtr;
    j, dlen, klen : word;
begin
  if ValidSrtId(srtId) then
  begin
    for j := 1 to srtStatArr[srtId].nbrRec do
      GenBinRetDelSmRec(srtRootArr[srtId], d, dlen, k, klen);
    srtStatArr[srtId].nbrRec := 0;
    srtStatArr[srtId].srtState := GenSrtSt_NV
  end
  else
    GenSrtEndF := GenSrtErr_ISI
end;

procedure GenSrtStat (var srtStatus : SrtStatRec; srtId :word);
begin
     srtStatus := srtStatArr[srtId]
end;

procedure GenSrtMsg (srtStatus : word; var srtString : SrtStr);
begin
     if srtStatus <= MAX_MSG then
        srtString := SrtMsg[srtStatus + 1]
end;

begin
  for j := 1 to MAX_SRTS do
    srtStatArr[j].srtState := GenSrtSt_NV;
end.